### CGS algorithm for polynomials and modules ########


with(PolynomialIdeals):
with(LinearAlgebra):


## Part 1: CGS algorithm for parametric polynomials (1-8) ##

#### 1. CGS_main: compute the comprehensive Groebner system of  an ideal genrated by parametric polynomials ###
## Input: Equ_set --- a set of polynomials in parameters (equality constraints) ##
##            DisEqu_set --- a set of polynomials in parameters (inequality constraints) ##
##            poly_set ---  a set of  polynomials  in variables and parameters ##
##            Var_set ---  a set of  variables   ##
##            Para_set --- a set of parameters  ##
##            VarOrder --- a monomial order w.r.t.  variables   ##
##            ParaOrder --- a monomial order w.r.t.  parameters ## 
## Output: a finite set of 3-tuples (Ei, Ni, Gi) such that {(V(Ei)\V(Ni), Gi)} constitutes a minimal comprehensive Groebner system of "poly_set" on " V(Equ_set) \ V(DisEqu_set) " ##

CGS_main:=proc(Equ_set,DisEqu_set,poly_set,Var_set, Para_set,VarOrder,ParaOrder)
 local Order1,Order2,Ord,E,N,F,X,U,G,Gr,GrxN,CGS,NewG,Gm,h,Lc,NewDisEqu_set,H,i;
 
 Order1:=VarOrder;
 Order2:=ParaOrder;
 Ord:=prod(Order1,Order2);
 E:=Polysqr(Equ_set);
 N:=Polysqr(DisEqu_set);
 F:=poly_set;
 X:=Var_set;
 U:=Para_set; 
 if (not consistent(E,N)) then
    return {};
 else
    G:=Groebner[Basis](F union E, Ord);
    if PolynomialIdeals[IdealMembership](1, <op(G)>) then
       return {[E,N,{1}]};
    else
       Gr:=PolyOnlyPara(G,X);
       GrxN:=Polysqr(SetMulti(Gr,N));
       if (not consistent(E,GrxN)) then
          CGS:={};
       else
          if nops(Gr)=0 then
             CGS:={};
 　　　　  else
             CGS:={[E,GrxN,{1}]};
          fi;
       fi;
 
       if (not consistent(Gr,N)) then
           return CGS;
       else 
           NewG:={op(G)} minus Gr;
           if nops(NewG)=0 then
              CGS:=CGS union {[Polysqr(Gr),N,{0}]};
              return CGS;
           fi;
           Gm:={op(MDBasis(NewG,Order1))};
           h:=MDBasisLc(Gm,Order1)[1];
           Lc:=MDBasisLc(Gm,Order1)[2];
           if consistent(Gr,SetMulti(N,{h})) then 
              CGS:=CGS union {[Polysqr(Gr),Polysqr(SetMulti(N,{h})),Gm]};
           fi;
           NewDisEqu_set:=N;
           H:=1;
           for i from 1 to nops(Lc) do
               CGS:=CGS union CGS_main(Gr union {Lc[i]}, NewDisEqu_set, NewG, X, U, Order1,Order2);
               H:=H*Lc[i];
               NewDisEqu_set:=SetMulti(N,{H});
           od;
           return CGS;
        fi; 
     fi;
  fi;  
 end proc:

#### 2.consistent: check the consistency of the two sets (whether V(E)\V(N) is empty) ###
## Input: E --- a set of polynomials in parameters (equality constraints) ##
##            N --- a set of polynomials in parameters (inequality constraints) ##  
## Output: false/true（if V(E)\V(N) is not empty, it is true） ##

consistent:=proc(E,N)  
 local n,r,i; 
 n:=nops(N);
 r:=false; 
 for i from 1 to n do
    if (not PolynomialIdeals[RadicalMembership](N[i], PolynomialIdeals[PolynomialIdeal](op(E)))) then
       r:=true;
       break;
    fi;  
 od; 
 return r;
 end proc:

#### 3. Polysqr: compute the set of the squarefree parts of all polynomials in a set ###
## Input: F--- a set of polynomials ##
## Output: a set of squarefree polynomials  ##
Polysqr:=proc(F)  
local L,h,L1,j,f,F1; 
F1:={};
for f in F do
    L:=factors(f);
    h:=1;
    L1:=map(numer,L[2]);
    for j from 1 to nops(L1) do
        h:=h*L1[j][1];
    od;
    F1:=F1 union {h};
od;

return F1;
end proc:


### 4. PolyOnlyPara:  find all the polynomials which does NOT have main variables from the polynomial set G ###
## Input: G --- a set of polynomials in variables and parameters ##
##            Var_set ---  a set of  variables   ##
## Output: a set of polynomials in parameters ##

PolyOnlyPara:=proc(G,Var_set)  
 local Gr,p,c,c1; 
 Gr:={};

 for p in G do
     if degree(p,Var_set)=0 then
        Gr:=Gr union {p};
    fi;  
 od; 

 return Gr;
 end proc:

#### 5. SetMulti: compute the product of two sets###
## Input: A --- a set of polynomials ##
##            B --- a set of polynomials  ##  
## Output:  a set of polynomials  ##

 SetMulti:=proc(A,B)  
 local n1,n2,C,i,j;
 
 n1:=nops(A);
 n2:=nops(B);
 C:={};
 
 if n1=0 then
    C:=B;
 else
    if n2=0 then
       C:=A;
    else 
       for i from 1 to n1 do
           for j from 1 to n2 do
               C:=C union {A[i]*B[j]};
           od;
       od;
    fi;
 fi;
 
 return C;
 end proc:


### 6. MDBasis: compute the minimal Dickson basis ###
## Input: GB --- a set of polynomials ##
##            Ord --- a monomial order  ##  
## Output:  a list of polynomials  ##

MDBasis:=proc(GB,Ord)
 local MG,i,New;
 
 MG:=[];
 for i from 1 to nops(GB) do
     New:=GB[i];
     MG:=InsertGB(New, MG, Ord);
 od;
 
 return MG;
 end proc:

### 7. InsertGB: inserts the new polynomial into the GB set ####
## Input: New --- a polynomial ##
##            OldGB_List --- a list of polynomials  ##  
##            Ord --- a monomial order  ##  
## Output:  a list of polynomials  ##

InsertGB:=proc(New, OldGB_List, Ord)
 local i,u,v,r,NewGB_List,List,L1,L2,r1,r2;
 NewGB_List:=OldGB_List;
 u:=New;
 r:=true;
 List:=[];
 L2:=0;
 if (nops(OldGB_List)=0) then
     NewGB_List:=[New];
 else
    for i from 1 to nops(OldGB_List) do
        v:=OldGB_List[i];
        r1:=divide(Groebner[LeadingMonomial](u,Ord),Groebner[LeadingMonomial](v,Ord));
        r2:=divide(Groebner[LeadingMonomial](v,Ord),Groebner[LeadingMonomial](u,Ord));
        if r1 then
           r:=false;
           break;
 	else
           if r2 then 
              L1:=L2;
              L2:=i;
              List:=[op(List),op((L1+1)..(L2-1),OldGB_List)]; 
 	   fi;
        fi;
    od;
 fi;  
 
 if r then
    NewGB_List:=[op(List), op((L2+1)..nops(OldGB_List),OldGB_List), u ];
 fi;
 
 return NewGB_List; 
 end proc:

### 8. MDBasisLc: compute the set and the minimal common multiple of  leading coefficients of all polynomial in the minimal Dickson basis ####
## Input: MG --- a list of polynomials (i.e.  the minimal Dickson basis ) ## 
##            Ord --- a monomial order  ##  
## Output:  a polynomial and a list of polynomials ##

MDBasisLc:=proc(MG,Ord)
local h,i,LcSet, lc,j,C,C1;
h:=1;
LcSet:=[];
 
 for i from 1 to nops(MG) do  
     lc:=Groebner[LeadingCoefficient](MG[i],Ord);
     if not type(lc,  'constant') then 
       h:=lcm(h, lc);
     end if;
 od;

C:=factors(h);
C1:=C[2];
for j from 1 to nops(C1) do
    LcSet:=[op(LcSet),C1[j][1]];
od;
if nops(LcSet)=0 then 
   LcSet:=[1];
fi;
 
 return h,LcSet;
 end proc:


## Part 2  CGS algorithm for modules over the parametric polynomial ring(1-2)  #####

### 1.  Onedegree_polys:  select elements from GB of the module whose degrees of the position variables are one，and convert them into corresponding vector form ###
## Input: GB--- a minimal CGS on some  branch ## 
##        Position_set---   a set of position variables  (or called the placeholder variables ) ##
## Output:  a set of vectors whose degrees of all  position variables are one ##

Onedegree_polys:=proc (GB, Position_set) 
 local MGB,p,v,i; 
 MGB:={};

 for p in GB do 
    if degree(p, Position_set)=1 then
       v:=[];
       for i to nops(Position_set) do
           v:=[op(v),coeff(p,Position_set[i])];
       od;
       MGB:=MGB union {v};
    fi;
 od;

 return MGB;
 end proc:

### 2. ModuleCGS: compute CGS for modules by call the CGS algorithm for parametric polynomials ###
## Input: Equ_set --- a set of polynomials in parameters (equality constraints) ##
##        DisEqu_set --- a set of polynomials in parameters (inequality constraints) ##
##        Vectors_set ---  a set of vectors in a module on normal variables and parameters ##
##        Position_set---   a set of position variables  (or called the placeholder variables ) ##
##        NewVar_set ---  a set of normal variables and position variables  ##
##        Para_set --- a set of parameters  ##
##        ModOrder --- a module order w.r.t. normal variables and positions variables  ##
##        ParaOrder --- a monomial order w.r.t.parameters ## 
## Output: a finite set of 3-tuples (Ei, Ni, Gi) such that {(V(Ei)\V(Ni), Gi)} constitutes a minimal comprehensive Groebner system of "Vectors_set" on " V(Equ_set) \ V(DisEqu_set) " ## 

ModuleCGS:=proc(Equ_set, DisEqu_set, Vectors_set, Position_set, NewVar_set, Para_set, ModOrder, ParaOrder) 
local n,m,Poly_set,i,j,G,k,MCGS;
n:=nops(Vectors_set); 
m:=nops(Position_set);
Poly_set:={seq(ListTools[DotProduct](Vectors_set[i], [op(1..m,Position_set)]),i=1..n)};
## regard the position variables as normal variables, then convert vectors to polynomials in a set of variables and position variables (i.e., f:=a*x*e[1]+b*x*y*e[2], e[1],e[2] are the position variables)##

for i to m do 
  for j to m do 
      Poly_set:=Poly_set union {Position_set[i]*Position_set[j]}; # Adding the product of the unit vectors (position variables) into the vector set (polynomial set) to speed the computation up  ##
  od;
od;
G:=CGS_main(Equ_set, DisEqu_set, Poly_set, NewVar_set, Para_set, ModOrder, ParaOrder);
MCGS:={}; 
for k to nops(G) do 
    MCGS:=MCGS union {[G[k][1],G[k][2],Onedegree_polys(G[k][3], Position_set)]}; 
od; 
return MCGS;
end proc:
